home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / amok_lha / amok08.lha / MemSystem1.1e / MemSystem.mod < prev    next >
Text File  |  1993-08-15  |  5KB  |  195 lines
  1. (**********************************************************************
  2.  
  3.     :Program.       MemSystem.mod
  4.     :Contents.     Lowlevel System Support
  5.     :Author.        Nicolas Benezan [bne]
  6.     :Address.    Postwiesenstr. 2, D7000 Stuttgart 60
  7.     :Phone.      711/333679
  8.     :Copyright.  Public Domain
  9.     :Language.      Modula-2
  10.     :Translator. M2Amiga AMSoft
  11.     :Imports.     IntuiStruct 1.0 [bne]
  12.     :History.     V1.0b [bne] 17.06.88 (pre-version, private)
  13.     :History.     V1.1d [bne] 09.07.88 (+ TaskMem)
  14.     :History.     V1.1e [bne] 28.10.88 (Bug corrected)
  15.     :Remark.     works with CLI now !
  16.     
  17. **********************************************************************)
  18.  
  19. IMPLEMENTATION MODULE MemSystem;
  20.  
  21. FROM Exec    IMPORT AvailMem,MemReqSet,MemReqs,Forbid,Permit,
  22.         AddHead,Remove,MemList,MemEntry,Node,List,AllocEntry,
  23.                 FreeEntry,TaskPtr,FindTask;
  24. FROM ExecSupport IMPORT NewList;
  25. FROM Arts    IMPORT Assert,Terminate,CurrentLevel,TermProcedure,
  26.         wbStarted;
  27. FROM Intuition    IMPORT IDCMPFlagSet,IntuiText,AutoRequest;
  28. FROM Graphics    IMPORT jam1;
  29. FROM IntuiStruct IMPORT StructText;
  30. FROM SYSTEM    IMPORT ADR,ADDRESS;
  31.  
  32. CONST    NoIDCMP=IDCMPFlagSet{};
  33.         StdMinMem=20*1024;
  34.         StdHysteresis=30*1024;
  35.         ReqWidth=320;
  36.         ReqHeight=72;
  37.         ThisTask=NIL;
  38.         CHIP=MemReqSet{chip,memClear};
  39.         ANY=MemReqSet{memClear};
  40.         NodeName="MemSystemEntry";
  41.  
  42. TYPE    TaskMemEntry=RECORD
  43.       memList:MemList;
  44.           memEntry:MemEntry;
  45.         END;
  46.         TaskMemEntryPtr=POINTER TO TaskMemEntry;
  47.  
  48. VAR    Header,Body,Positive,Negative:IntuiText;
  49.  
  50. PROCEDURE YesNoRequest(BodyText,PositiveText,NegativeText:ADDRESS;
  51.     PosFlags:IDCMPFlagSet;VAR Answer:BOOLEAN);
  52. BEGIN
  53.   Body.iText:=BodyText;
  54.   Positive.iText:=PositiveText;
  55.   Negative.iText:=NegativeText;
  56.   Answer:=AutoRequest(Window,ADR(Header),ADR(Positive),ADR(Negative),
  57.       PosFlags,NoIDCMP,ReqWidth,ReqHeight);
  58. END YesNoRequest;
  59.  
  60. PROCEDURE DeallocTaskMem(VAR Pointer:ADDRESS);
  61. VAR    Task:TaskPtr;
  62.     EntryPtr:TaskMemEntryPtr;
  63. BEGIN
  64.   Task:=FindTask(ThisTask);
  65.   EntryPtr:=ADDRESS(Task^.memEntry.head);
  66.   WHILE (EntryPtr^.memList.node.succ#NIL)
  67.      AND((EntryPtr^.memEntry.addr#Pointer)
  68.       OR(EntryPtr^.memList.numEntries#1)) DO
  69.     EntryPtr:=ADDRESS(EntryPtr^.memList.node.succ);
  70.   END;
  71.   Assert(EntryPtr^.memList.node.succ#NIL,ADR("can't Free() free Memory"));
  72.   Remove(ADDRESS(EntryPtr));
  73.   FreeEntry(ADDRESS(EntryPtr));
  74.   Pointer:=NIL;
  75. END DeallocTaskMem;
  76.  
  77. PROCEDURE AllocTaskMem(VAR Pointer:ADDRESS;Size:LONGINT;Reqs:MemReqSet);
  78. VAR    Task:TaskPtr;
  79.     Entry:TaskMemEntry;
  80.         EntryPtr:TaskMemEntryPtr;
  81.     Retry:BOOLEAN;
  82.  
  83.   PROCEDURE LowMemWarning;
  84.   BEGIN
  85.     YesNoRequest(ADR("Low memory warning"),ADR(RETRY),ADR(CANCEL),NoIDCMP,
  86.         Retry);
  87.   END LowMemWarning;
  88.  
  89. BEGIN
  90.   REPEAT
  91.     Forbid;
  92.     Task:=FindTask(ThisTask);
  93.     WITH Entry DO
  94.       memList.numEntries:=1;
  95.       memEntry.reqs:=Reqs;
  96.       memEntry.length:=Size;
  97.     END;
  98.     EntryPtr:=ADDRESS(AllocEntry(ADR(Entry)));
  99.     IF LONGINT(EntryPtr)<0 THEN
  100.       Pointer:=NIL;
  101.     ELSE
  102.       Pointer:=EntryPtr^.memEntry.addr;
  103.       EntryPtr^.memList.node.name:=ADR(NodeName);
  104.       AddHead(ADR(Task^.memEntry),ADDRESS(EntryPtr));
  105.     END;
  106.     IF Pointer=NIL THEN
  107.       Permit;
  108.       LowMemWarning;
  109.     ELSIF AvailMem(MemReqSet{chip,largest})<minMemory THEN
  110.       DeallocTaskMem(Pointer);
  111.       Permit;
  112.       LowMemWarning;
  113.     ELSE
  114.       Permit;
  115.     END;
  116.   UNTIL (Pointer#NIL)OR NOT Retry;
  117. END AllocTaskMem;
  118.  
  119. PROCEDURE DiscardHeap;
  120. VAR    Task:TaskPtr;
  121.     EntryPtr,NextEntryPtr:TaskMemEntryPtr;
  122. BEGIN
  123.   Forbid;
  124.   Task:=FindTask(ThisTask);
  125.   EntryPtr:=ADDRESS(Task^.memEntry.head);
  126.   WHILE EntryPtr#NIL DO
  127.     NextEntryPtr:=ADDRESS(EntryPtr^.memList.node.succ);
  128.     IF EntryPtr^.memList.node.name=ADR(NodeName) THEN
  129.       Remove(ADDRESS(EntryPtr));
  130.       FreeEntry(ADDRESS(EntryPtr));
  131.     END;
  132.     EntryPtr:=NextEntryPtr;
  133.   END;
  134.   Permit;
  135. END DiscardHeap;
  136.  
  137. PROCEDURE Allocate(VAR Pointer:ADDRESS;Size:LONGINT);
  138. BEGIN
  139.   AllocTaskMem(Pointer,Size,ANY);
  140. END Allocate;
  141.  
  142. PROCEDURE AllocMem(VAR Pointer:ADDRESS;Size:LONGINT;Chip:BOOLEAN);
  143. VAR    ChipReq:MemReqSet;
  144. BEGIN
  145.   IF Chip THEN
  146.     ChipReq:=CHIP;
  147.   ELSE
  148.     ChipReq:=ANY;
  149.   END;
  150.   AllocTaskMem(Pointer,Size,ChipReq);
  151. END AllocMem;
  152.  
  153. PROCEDURE Deallocate(VAR Pointer:ADDRESS);
  154. BEGIN
  155.   DeallocTaskMem(Pointer);
  156. END Deallocate;
  157.  
  158. PROCEDURE ExitQuiet;
  159. BEGIN
  160.   Terminate(CurrentLevel());
  161. END ExitQuiet;
  162.  
  163. PROCEDURE RecoverableExit(ReqBody,PosText,NegText:ADDRESS);
  164. VAR    recover:BOOLEAN;
  165. BEGIN
  166.   YesNoRequest(ReqBody,PosText,NegText,NoIDCMP,recover);
  167.   IF NOT recover THEN
  168.     ExitQuiet;
  169.   END;
  170. END RecoverableExit;
  171.  
  172. PROCEDURE DeadEndExit(ReqBody:ADDRESS);
  173. VAR    Dummy:BOOLEAN;
  174. BEGIN
  175.   Body.iText:=ReqBody;
  176.   Negative.iText:=ADR(CANCEL);
  177.   Dummy:=AutoRequest(Window,ADR(Header),NIL,ADR(Negative),
  178.       NoIDCMP,NoIDCMP,ReqWidth,ReqHeight);
  179.   ExitQuiet;
  180. END DeadEndExit;
  181.  
  182. BEGIN
  183.   minMemory:=StdMinMem;
  184.   Hysteresis:=StdHysteresis;
  185.   Window:=NIL;
  186.   ErrHeader:="Modula-2 MemSystem";
  187.   StructText(Header,0,1,jam1,15,5,ADR(ErrHeader),ADR(Body));
  188.   StructText(Body,0,1,jam1,15,15,NIL,NIL);
  189.   StructText(Positive,0,1,jam1,6,3,NIL,NIL);
  190.   StructText(Negative,0,1,jam1,6,3,NIL,NIL);
  191.   IF NOT wbStarted THEN
  192.     TermProcedure(DiscardHeap);
  193.   END;
  194. END MemSystem.
  195.